home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / ibcl-low.lsp < prev    next >
Encoding:
Text File  |  1992-07-09  |  11.2 KB  |  333 lines

  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The version of low for Kyoto Common Lisp (KCL)
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; The reason these are here is because the KCL compiler does not allow
  32. ;;; LET to return FIXNUM values as values of (c) type int, hence the use
  33. ;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
  34. ;;; conversion of ints to objects.
  35. ;;; 
  36. (defmacro %logand (&rest args)
  37.   (reduce-variadic-to-binary 'logand args 0 t 'fixnum))
  38.  
  39. ;(defmacro %logxor (&rest args)
  40. ;  (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))
  41.  
  42. (defmacro %+ (&rest args)
  43.   (reduce-variadic-to-binary '+ args 0 t 'fixnum))
  44.  
  45. ;(defmacro %- (x y)
  46. ;  `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
  47.  
  48. (defmacro %* (&rest args)
  49.   (reduce-variadic-to-binary '* args 1 t 'fixnum))
  50.  
  51. (defmacro %/ (x y)
  52.   `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))
  53.  
  54. (defmacro %1+ (x)
  55.   `(the fixnum (1+ (the fixnum ,x))))
  56.  
  57. (defmacro %1- (x)
  58.   `(the fixnum (1- (the fixnum ,x))))
  59.  
  60. (defmacro %svref (vector index)
  61.   `(svref (the simple-vector ,vector) (the fixnum ,index)))
  62.  
  63. (defsetf %svref (vector index) (new-value)
  64.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
  65.          ,new-value))
  66.  
  67.  
  68. ;;;
  69. ;;; std-instance-p
  70. ;;;
  71. (si:define-compiler-macro std-instance-p (x)
  72.   (once-only (x)
  73.     `(and (si:structurep ,x)
  74.       (eq (si:structure-name ,x) 'std-instance))))
  75.  
  76. (import 'si:structurep)
  77.  
  78. (defmacro structure-type (x)
  79.   `(si:structure-name ,x))
  80.  
  81. (dolist (inline '((si:structurep
  82.             ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
  83.             compiler::inline-always)
  84.           (si:structure-name
  85.             ((t) t nil nil "(#0)->str.str_name")
  86.             compiler::inline-unsafe)))
  87.   (setf (get (first inline) (third inline)) (list (second inline))))
  88.  
  89. (setf (get 'cclosure-env 'compiler::inline-always)
  90.       (list '((t) t nil nil "(#0)->cc.cc_env")))
  91.  
  92. ;;;
  93. ;;; turbo-closure patch.  See the file kcl-mods.text for details.
  94. ;;;
  95. #+:turbo-closure
  96. (progn
  97. (CLines
  98.   "object tc_cc_env_nthcdr (n,tc)"
  99.   "object n,tc;                        "
  100.   "{return (type_of(tc)==t_cclosure&&  "
  101.   "         tc->cc.cc_turbo!=NULL&&    "
  102.   "         type_of(n)==t_fixnum)?     "
  103.   "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
  104.   "         Cnil;                      "
  105.   "}                                   "
  106.   )
  107.  
  108. (defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))
  109.  
  110. (setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
  111.       '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
  112. )
  113.  
  114.  
  115. ;;;; low level stuff to hack compiled functions and compiled closures.
  116. ;;;
  117. ;;; The primary client for this is fsc-low, but since we make some use of
  118. ;;; it here (e.g. to implement set-function-name-1) it all appears here.
  119. ;;;
  120.  
  121. (eval-when (compile eval)
  122.  
  123. (defmacro define-cstruct-accessor (accessor structure-type field value-type
  124.                         field-type tag-name)
  125.   (let ((setf (intern (concatenate 'string "SET-" (string accessor))))
  126.     (caccessor (format nil "pcl_get_~A_~A" structure-type field))
  127.     (csetf     (format nil "pcl_set_~A_~A" structure-type field))
  128.     (vtype (intern (string-upcase value-type))))
  129.     `(progn
  130.        (CLines ,(format nil "~A ~A(~A)                ~%~
  131.                              object ~A;               ~%~
  132.                              { return ((~A) ~A->~A.~A); }       ~%~
  133.                                                       ~%~
  134.                              ~A ~A(~A, new)           ~%~
  135.                              object ~A;               ~%~
  136.                              ~A new;                  ~%~
  137.                              { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
  138.                             "
  139.             value-type caccessor structure-type 
  140.             structure-type
  141.             value-type structure-type tag-name field
  142.             value-type csetf structure-type
  143.             structure-type 
  144.             value-type 
  145.             value-type structure-type tag-name field field-type
  146.             ))
  147.  
  148.        (defentry ,accessor (object) (,vtype ,caccessor))
  149.        (defentry ,setf (object ,vtype) (,vtype ,csetf))
  150.  
  151.  
  152.        (defsetf ,accessor ,setf)
  153.  
  154.        )))
  155. )
  156. ;;; 
  157. ;;; struct cfun {                   /*  compiled function header  */
  158. ;;;         short   t, m;
  159. ;;;         object  cf_name;        /*  compiled function name  */
  160. ;;;         int     (*cf_self)();   /*  entry address  */
  161. ;;;         object  cf_data;        /*  data the function uses  */
  162. ;;;                                 /*  for GBC  */
  163. ;;;         char    *cf_start;      /*  start address of the code  */
  164. ;;;         int     cf_size;        /*  code size  */
  165. ;;; };
  166. ;;; add field-type tag-name
  167. (define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
  168. (define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())" 
  169.                          "cf")
  170. (define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
  171. (define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
  172. (define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")
  173.  
  174. (CLines
  175.   "object pcl_cfunp (x)              "
  176.   "object x;                         "
  177.   "{if(x->c.t == (int) t_cfun)       "
  178.   "  return (Ct);                    "
  179.   "  else                            "
  180.   "    return (Cnil);                "
  181.   "  }                               "
  182.   )
  183.  
  184. (defentry cfunp (object) (object pcl_cfunp))
  185.  
  186. ;;; 
  187. ;;; struct cclosure {               /*  compiled closure header  */
  188. ;;;         short   t, m;
  189. ;;;         object  cc_name;        /*  compiled closure name  */
  190. ;;;         int     (*cc_self)();   /*  entry address  */
  191. ;;;         object  cc_env;         /*  environment  */
  192. ;;;         object  cc_data;        /*  data the closure uses  */
  193. ;;;                                 /*  for GBC  */
  194. ;;;         char    *cc_start;      /*  start address of the code  */
  195. ;;;         int     cc_size;        /*  code size  */
  196. ;;; };
  197. ;;; 
  198. (define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object"
  199.                          "(object)" "cc")          
  200. (define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int" 
  201.                          "(int (*)())" "cc")
  202. (define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
  203.                           "(object)" "cc")
  204. (define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" 
  205.                          "(char *)" "cc")
  206. (define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
  207.              "(int)" "cc")
  208. (define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
  209.                          "(object)" "cc")
  210.  
  211.  
  212. (CLines
  213.   "object pcl_cclosurep (x)          "
  214.   "object x;                         "
  215.   "{if(x->c.t == (int) t_cclosure)   "
  216.   "  return (Ct);                    "
  217.   "  else                            "
  218.   "   return (Cnil);                 "
  219.   "  }                               "
  220.   )
  221.  
  222. (defentry cclosurep (object) (object pcl_cclosurep))
  223.  
  224.   ;;   
  225. ;;;;;; Load Time Eval
  226.   ;;
  227. ;;; 
  228.  
  229. ;;; This doesn't work because it looks at a global variable to see if it is
  230. ;;; in the compiler rather than looking at the macroexpansion environment.
  231. ;;; 
  232. ;;; The result is that if in the process of compiling a file, we evaluate a
  233. ;;; form that has a call to load-time-eval, we will get faked into thinking
  234. ;;; that we are compiling that form.
  235. ;;;
  236. ;;; THIS NEEDS TO BE DONE RIGHT!!!
  237. ;;; 
  238. ;(defmacro load-time-eval (form)
  239. ;  ;; In KCL there is no compile-to-core case.  For things that we are 
  240. ;  ;; "compiling to core" we just expand the same way as if were are
  241. ;  ;; compiling a file since the form will be evaluated in just a little
  242. ;  ;; bit when gazonk.o is loaded.
  243. ;  (if (and (boundp 'compiler::*compiler-input*)  ;Hack to see of we are
  244. ;       compiler::*compiler-input*)          ;in the compiler!
  245. ;      `'(si:|#,| . ,form)
  246. ;      `(progn ,form)))
  247.  
  248. (defmacro load-time-eval (form)
  249.   (read-from-string (format nil "'#,~S" form)))
  250.  
  251. (defmacro memory-block-ref (block offset)
  252.   `(svref (the simple-vector ,block) (the fixnum ,offset)))
  253.  
  254.   ;;   
  255. ;;;;;; Generating CACHE numbers
  256.   ;;
  257. ;;; This needs more work to be sure it is going as fast as possible.
  258. ;;;   -  The calls to si:address should be open-coded.
  259. ;;;   -  The logand should be open coded.
  260. ;;;   
  261.  
  262. ;(defmacro symbol-cache-no (symbol mask)
  263. ;  (if (and (constantp symbol)
  264. ;       (constantp mask))
  265. ;      `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))
  266. ;      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  267.  
  268. (defmacro object-cache-no (object mask)
  269.   `(logand (the fixnum (si:address ,object)) ,mask))
  270.  
  271.   ;;   
  272. ;;;;;; printing-random-thing-internal
  273.   ;;
  274. (defun printing-random-thing-internal (thing stream)
  275.   (format stream "~O" (si:address thing)))
  276.  
  277.  
  278. (defun set-function-name-1 (fn new-name ignore)
  279.   (cond ((cclosurep fn)
  280.      (setf (cclosure-name fn) new-name))
  281.     ((cfunp fn)
  282.      (setf (cfun-name fn) new-name))
  283.     ((and (listp fn)
  284.           (eq (car fn) 'lambda-block))
  285.      (setf (cadr fn) new-name))
  286.     ((and (listp fn)
  287.           (eq (car fn) 'lambda))
  288.      (setf (car fn) 'lambda-block
  289.            (cdr fn) (cons new-name (cdr fn)))))
  290.   fn)
  291.  
  292.  
  293.  
  294.  
  295. #|
  296. (defconstant most-positive-small-fixnum 1024)  /* should be supplied */
  297. (defconstant most-negative-small-fixnum -1024) /* by ibuki */
  298.  
  299. (defmacro symbol-cache-no (symbol mask)
  300.   (if (constantp mask)
  301.       (if (and (> mask 0)
  302.            (< mask most-positive-small-fixnum))
  303.       (if (constantp symbol)
  304.           `(load-time-eval (coffset ,symbol ,mask 2))
  305.         `(coffset ,symbol ,mask 2))
  306.     (if (constantp symbol)
  307.         `(load-time-eval 
  308.            (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))
  309.       `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  310.     `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  311.  
  312.  
  313. (defmacro object-cache-no (object mask)
  314.   (if (and (constantp mask)
  315.        (> mask 0)
  316.        (< mask most-positive-small-fixnum))
  317.       `(coffset ,object ,mask 4)
  318.     `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))
  319.  
  320. (CLines
  321.   "object pcl_coffset (sym,mask,lshift)"
  322.   "object sym,mask,lshift;"
  323.   "{"
  324.   "    return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"
  325.   "}"
  326.   )
  327.  
  328. (defentry coffset (object object object) (object pcl_coffset))
  329.  
  330.  
  331. |#
  332.  
  333.